(import (min "Math.Min" the-arithmetic-type)
	(max "Math.Max" the-arithmetic-type)
	(abs "Math.Abs" the-arithmetic-type))

(define-imported-class (general-array "System.Array") object)
(define general-array (type-expression-value 'general-array))

(import-static (array-type-of "Utilities.ArrayTypeOf"
			      (proc (clr-type) clr-type))
	       (make-array "System.Array.CreateInstance"
			   (proc (clr-type integer) general-array)))

(define-imported-class (procedure-syntax-error (string msg)
					       (object obj))
  parse-error)
(define-imported-class (invalid-argument-declaration-error (object obj))
  parse-error)
(define-imported-class (missing-body-error (string msg) (object obj))
  parse-error)


(define-initialized-module (lisp lambdas)
  (define-class user-procedure
    (apply-interface-procedure "IArglist" "IDocumentable")
    (define parent-environment (public environment) null)
    (define source-expression (public expression) null)
    (define psnl "staticNestingLevel" (protected integer) 0)
    (define argument-list (protected (array object)) null)
    (define docs "documentation" (protected string) null)

    (define (set-documentation p (string s)) (public void)
      (set (docs p) s))

    (define (documentation p)
      (docs p))

    (define (arglist p) (argument-list p)))

  (define-class interpreted-procedure-base user-procedure
    (define argument-variables (protected (array local-variable)) null)
    (define procedure-body "body" (protected expression) null)

    (define (check-argument-types proc ((array object) arglist)) (public void)
      (dotimes (i (length arglist))
	(check-type (vector-ref (argument-variables proc) i)
		    (vector-ref arglist i))))

    (define (apply proc ((array object) args))
      (apply-with-stack proc args current-thread-eval-stack))

    (define (apply-with-stack proc ((array object) args) (eval-stack estack))
      (let ((e (environment proc
			    args
			    (parent-environment proc)
			    (psnl proc))))
	(apply-with-environment proc e estack)))

    (define (apply-with-environment proc
				    (environment e)
				    (eval-stack estack))
      (protected object)
      (check-argument-types proc (env-data e))
      (let ((result (eval (procedure-body proc)
			  e
			  estack)))
	(while (is-the-tail-call-cookie? result)
	  (set result
	       (tail-apply (current-procedure estack)
			   (current-arguments estack)
			   estack)))
	result))

    (define (tail-apply proc args (eval-stack estack))
      (check-argument-types proc args)
      (let ((e (environment proc
			    args
			    (parent-environment proc)
			    (psnl proc))))
	(tail-apply-with-environment proc e estack)))

    (define (tail-apply-with-environment proc
					 (environment e)
					 (eval-stack estack))
      (protected object)
      (let ((m (get-global-mode (proc-execution-mode proc))))
	(cond ((normal? m)
	(eval (procedure-body proc)
			    e
			    estack))
	      (else
	       (when (breakpoint m)
		 (break null null))
	       (let ((t (call-record proc (env-data e))))
		 (when (trace m)
		   (log-event t))
		 (let ((result (eval (procedure-body proc)
				     e
				     estack)))
		   (set (call-result t) result)
		   result)))))))

  (define-class (interpreted-procedure procedure-name
				       argument-list
				       argument-variables
				       procedure-body
				       parent-environment
				       source-expression
				       docs
				       psnl)
    interpreted-procedure-base
    ("[Serializable]")

    (define (apply-with-stack proc args estack)
      (check-nargs proc args (length (argument-variables proc)))
      (apply-with-stack base args estack))

    (define (tail-apply proc args estack)
      (check-nargs proc args (length (argument-variables proc)))
      (tail-apply base args estack)))

  (define-class (interpreted-procedure-variable-args procedure-name
						     argument-list
						     argument-variables
						     required-arguments
						     optional-arguments
						     rest-arg
						     rest-arg-type
						     keywords-start
						     procedure-body
						     parent-environment
						     source-expression
						     docs
						     psnl)
    interpreted-procedure-base
    ("[Serializable]")

    (define required-arguments (public byte) 0)
    (define optional-arguments (public byte) 0)
    (define rest-arg (private signed-byte) 0)
    (define keywords-start (private signed-byte) 0)
    (define rest-arg-type (private clr-type) null)

    (define (has-rest-arg l) (public property boolean)
      (>= (rest-arg l) 0))
    (define (has-keyword-args l) (public property boolean)
      (>= (keywords-start l) 0))

    (define (check-keyword-arg ((array object) arglist)
			       (integer position)
			       (local-variable arg)
			       (environment env)
			       (eval-stack estack))
      (public static object)
      (while (< position (length arglist))
	(let ((k (as (vector-ref arglist position)
		     keyword)))
	  (when (null? k)
	    (throw (argument-type-exception "keyword name"
					    (vector-ref arglist position)
					    (type->clr-type keyword))))
	  (when (eq? (symbol-form k)
		     (vname arg))
	    (return (vector-ref arglist (+ position 1))))
	  (set position (+ position 2))))
      (eval (default-value arg) env estack))

    (define (process-argument-list proc
				   ((array object) args)
				   (eval-stack estack))
      (public environment)
      (let ((env-data (new-array object (length (argument-variables proc))))
	    (non-rest-args (+ (required-arguments proc)
				   (optional-arguments proc))))
	(let ((env (environment proc
				env-data
				(parent-environment proc)
			       (psnl proc)))
	      (supplied-non-rest (min non-rest-args (length args))))
	  (copy-subarray args 0 env-data 0 supplied-non-rest)
	  ;; Process defaults for optional args
	  (let ((defaulted supplied-non-rest))
	    (while (< defaulted non-rest-args)
	      (set (vector-ref env-data defaulted)
		   (eval (default-value (vector-ref (argument-variables proc)
						    defaulted))
			 env estack))
	      (set defaulted
		   (+ defaulted 1))))
	  ;; Process keyword args
	  (when (has-keyword-args proc)
	    (unless (= (modulo (- (length args)
				  non-rest-args)
			       2)
		       0)
	      (throw (argument-exception "Odd number of keyword arguments passed; must be even")))
	    (let ((key (keywords-start proc)))
	      (while (< key (length (argument-variables proc)))
		(set (vector-ref env-data key)
		     (check-keyword-arg args non-rest-args
					(vector-ref (argument-variables proc)
						    key)
					env
					estack))
		(set key (+ key 1)))))
	  (when (has-rest-arg proc)
	    ;; Make an array to hold the rest argument
	    (let ((rest-array (make-array (if (null? (rest-arg-type proc))
					      (type->clr-type object)
					      (rest-arg-type proc))
					  (- (length args) supplied-non-rest))))
	      ;; Rebind the rest arg to the array
	      (set (vector-ref env-data (rest-arg proc))
		   rest-array)
	      ;; Check arg types
	      (unless (or (null? (rest-arg-type proc))
			  (eq? (rest-arg-type proc) (type->clr-type object)))
		(dotimes (rindex (length rest-array))
		  (let ((rarg (vector-ref args (+ supplied-non-rest rindex))))
		    (unless (or (null? rarg)
				(eq? (rest-arg-type proc)
				     (type->clr-type object))
				(is-instance-of-type (rest-arg-type proc)
						     rarg))
		      (throw (argument-type-exception (vname (vector-ref (argument-variables proc)
									 (rest-arg proc)))
						      rarg
						      (rest-arg-type proc)))))))
	      ;; Copy args to the array
	      (copy-subarray args supplied-non-rest
			     rest-array 0
			     (length rest-array))))
	  env)))

    (define (apply-with-stack proc args estack)
      (when (< (length args)
	       (required-arguments proc))
	(wrong-number-of-args proc args))
      (let ((e (environment proc
			    args
			    (parent-environment proc)
			    (psnl proc))))
	(apply-with-environment proc
				(process-argument-list proc args estack)
				estack)))
;      (let ((env-data (new-array object (+ (required-arguments proc) 1))))
;	(copy-subarray args 0 env-data 0 (required-arguments proc))
;	(set (vector-ref env-data
;			 (required-arguments proc))
;	     (sublist args
;			  (required-arguments proc)
;			  (- (length args)
;			     (required-arguments proc))))
;	(apply-with-stack base env-data estack))
;      (apply-with-stack base
;			(process-argument-list proc args)
;			estack))

    (define (tail-apply proc args estack)
      (when (< (length args)
	       (required-arguments proc))
	(wrong-number-of-args proc args))
      (tail-apply-with-environment base
				   (process-argument-list proc args estack)
				   estack)))
;      (let ((env-data (new-array object (+ (required-arguments proc) 1))))
;	(copy-subarray args 0 env-data 0 (required-arguments proc))
;	(set (vector-ref env-data
;			 (required-arguments proc))
;	     (sublist args
;			  (required-arguments proc)
;			  (- (length args)
;			     (required-arguments proc))))
;	(tail-apply base env-data estack)))

  (define-class (lambda-expression lambda-name
				   argument-list argument-variables
				   required-arguments optional-arguments
				   rest-arg lambda-rest-arg-type keywords-start
				   lambda-body lambda-docs lsnl)
    expression
    ("[Serializable]")
    (define (initialize! this) (public void)
      (base-initializer this))
    (define lambda-name "name" (public symbol) null)
    (define argument-list (public (array object)) null)
    (define argument-variables (public (array local-variable)) null)
    (define required-arguments (public byte) 0)
    (define optional-arguments (public byte) 0)
    (define rest-arg (private signed-byte) 0)
    (define lambda-rest-arg-type "restArgType" (private clr-type) null)
    (define lambda-docs "documentation" (public string) null)
    (define keywords-start (private signed-byte) 0)

    (define lsnl "snl" (public integer) 0)
    (define lambda-body "body" (public expression) null)

    (define keywords (public static symbol)
      (intern "keywords:"))

    (define lambda-sign (public static symbol)
      (intern "->"))

    (define (has-rest-arg l) (public property boolean)
      (>= (rest-arg l) 0))
    (define (has-keyword-args l) (public property boolean)
      (>= (keywords-start l) 0))

    (define (count-with-clauses (ilist arr)) (public static integer)
      (let ((position 2))
	(while (and (< position (count arr))
		    (eq? (vector-ref arr position)
			 s-equal))
	  (set position (+ position 3)))
	(quotient position 3)))

    (define (simplify l parent tail?)
      (set (enclosing-expression l) parent)
      (set (lambda-body l)
	   (simplify (lambda-body l)
		     l
		     #t))
      l)

    (define (parse-argument-declaration spec (integer index) (integer snl)) (public static local-variable)
      (when (null? spec)
	(throw (new invalid-argument-declaration-error
		    spec)))
      (cond ((is? spec symbol)
	     (local-variable (cast symbol spec)
			     null ;(type->clr-type object)
			     null index snl))
	    ((is? spec ilist)
	     (let ((l (cast ilist spec)))
	       (let ((c (count l)))
		 (cond ((= c 2)
			(if (is? (vector-ref l 0) keyword)
			    (let ((vn (vector-ref l 0)))
			      (when (null? vn)
				(throw (parse-error "Null variable name"
						    spec)))
			      (when (not (is? vn symbol))
				(throw (parse-error "Variable name isn't a symbol"
						    spec)))
			      (local-variable (symbol-form (cast symbol vn))
					      null ;(type->clr-type object)
					      (constant (vector-ref l 1))
					      index snl))
			    (let ((vn1 (vector-ref l 1)))
			      (when (null? vn1)
				(throw (parse-error "Null variable name"
						    spec)))
			      (when (not (is? vn1 symbol))
				(throw (parse-error "Variable name isn't a symbol"
						    spec)))
			      (local-variable (symbol-form (cast symbol vn1))
					      (parse-type-expression (vector-ref l 0))
					      null
					      index snl))))
		       ((= c 3)
			(let ((vn2 (vector-ref l 1)))
			  (when (null? vn2)
			    (throw (parse-error "Null variable name"
						spec)))
			  (when (not (is? vn2 symbol))
			    (throw (parse-error "Variable name isn't a symbol"
						spec)))
			  (local-variable (symbol-form (cast symbol vn2))
					  (parse-type-expression (vector-ref l 0))
					  (constant (vector-ref l 2))
					  index snl)))
		       (else
			(throw (new invalid-argument-declaration-error
				    spec)))))))
	    (else
	     (throw (new invalid-argument-declaration-error
			 spec)))))

    (define (unparse l)
      (let ((args (argument-list l))
	    (has-name? (not (null? (lambda-name l))))
	    (b (lambda-body l))
	    (argc (length (argument-variables l))))
	(let ((name-slots (if has-name? 2 0)))
	  (let ((up (new-array object (+ name-slots
					 argc
					 2))))
	    (when has-name?
	      (set (vector-ref up 0)
		   (lambda-name l))
	      (set (vector-ref up 1) s-colon))
	    (dotimes (i argc)
	      (set (vector-ref up (+ i name-slots))
		   (vector-ref args i)))
	    (set (vector-ref up (+ argc name-slots))
		 (intern "->"))
	    (set (vector-ref up (+ argc name-slots 1))
		 (unparse b))
	    up))))

    (define (subexpressions e)
      (let ((initializers 0))
	(dotimes (i (length (argument-variables e)))
	  (unless (null? (default-value (vector-ref (argument-variables e)
						    i)))
	    (set initializers (+ initializers 1))))
	(let ((subexps (new-array object (+ initializers 1))))
	  (set (vector-ref subexps 0)
	       (lambda-body e))
	  (dotimes (j (length (argument-variables e)))
	    (unless (null? (default-value (vector-ref (argument-variables e)
						      j)))
	      (set (vector-ref subexps initializers)
		   (default-value (vector-ref (argument-variables e)
					      j)))
	      (set initializers (- initializers 1))))
	  (cast ilist subexps))))

    (define (eval l (environment env) estack)
      (let ((len (length (argument-list l))))
	(if (or (> (optional-arguments l)
		   0)
		(has-keyword-args l)
		(has-rest-arg l))
	    (interpreted-procedure-variable-args (lambda-name l)
						 (argument-list l)
						 (argument-variables l)
						 (required-arguments l)
						 (optional-arguments l)
						 (rest-arg l)
						 (lambda-rest-arg-type l)
						 (keywords-start l)
						 (lambda-body l)
						 env
						 l
						 (lambda-docs l)
						 (lsnl l))
	    (interpreted-procedure (lambda-name l)
				   (argument-list l)
				   (argument-variables l)
				   (lambda-body l)
				   env
				   l
				   (lambda-docs l)
				   (lsnl l))))))

  (define-parser (with "var = value ..." "body ...")
    "Creates local names for values\\nUse with* to allow successive names to be defined in terms of previous ones"
    with-parser s-with arr p
    (check-length arr 4 0)
    (let ((named? (eq? (vector-ref arr 2)
		       s-colon)))
      (let ((name (if named?
		      (vector-ref arr 1)
		      null))
	    (clauses (count-with-clauses (if named?
					     (rest (rest (cast ilist arr)))
					     (cast ilist arr)))))
	(let ((body-length (- (count arr)
			      (+ (* clauses 3)
				 (if named?
				     3
				     1)))))
	  (when (< body-length 1)
	    (throw (missing-body-error "With expression has not result expression(s)"
						     arr)))
	  (let ((lam (new-array object (+ clauses
					  body-length
					  3)))
		(app (new-array object (+ clauses 1)))
		(first-clause-position (if named? 3 1)))
	    (let ((body-start (+ (* clauses 3)
				 first-clause-position)))
	      (declare-source-alias lam
				    (vector-ref arr body-start))
	      (declare-source-alias app arr)
	      ;; Name it
	      (set (vector-ref lam 0)
		   (if named?
		       name
		       s-with2))
	      (set (vector-ref lam 1) s-colon)
	      ;; Copy clauses over
	      (dotimes (i clauses)
		(set (vector-ref lam (+ i 2))
		     (vector-ref arr (+ (* i 3)
					first-clause-position)))
		(set (vector-ref app (+ i 1))
		     (vector-ref arr (+ (* i 3)
					(+ first-clause-position 2)))))
	      (set (vector-ref app 0) lam)
	      (set (vector-ref lam (+ clauses 2)) lambda-sign)
	      ;; Copy body over
	      (dotimes (j body-length)
		(let (( e (vector-ref arr (+ body-start j))))
		  (when (eq? e s-equal)
		    (throw (parse-error "Found = in body of with - typeo in variables section?"
					arr)))
		  (set (vector-ref lam (+ j clauses 3))
		       e)))
	      ;; Parse it
	      (parse p app p)))))))

  (define-parser (with* "var = value ..." "body ...")
    "Creates local names for values.\\nAllows names to be defined in terms of previous names."
    with-star-parser
    s-with arr p
    (check-length arr 4 0)
    (let ((named? (eq? (vector-ref arr 2)
		       s-colon)))
      (let ((name (if named?
		      (vector-ref arr 1)
		      null))
	    (clauses (count-with-clauses (if named?
					     (rest (rest (cast ilist arr)))
					     (cast ilist arr)))))
	(let ((body-length (- (count arr)
			      (+ (* clauses 3)
				 (if named?
				     3
				     1)))))
	  (when (< body-length 1)
	    (throw (missing-body-error "With* appears to have no result expression(s)"
						 arr)))
	  (let ((lam (new-array object (+ (* 2 clauses)
					  body-length
					  3)))
		(app (new-array object (+ clauses 1)))
		(first-clause-position (if named? 3 1)))
	    (let ((body-start (+ (* clauses 3)
				 first-clause-position)))
	      (declare-source-alias lam
				    (vector-ref arr body-start))
	      (declare-source-alias app arr)
	      ;; Fill in name
	      (set (vector-ref lam 0)
		   (if named?
		       name
		       s-with-star2))
	      (set (vector-ref lam 1) s-colon)
	      (dotimes (i clauses)
		(let ((arg-name (vector-ref arr
					    (+ (* i 3)
					       (if named? 3 1)))))
		  (set (vector-ref lam (+ i 2))
		       arg-name)
		  (set (vector-ref app (+ i 1))
		       missing-value)
		  (let ((value-expression (vector-ref arr (+ (* i 3)
							     (if named? 5 3)))))
		    (set (vector-ref lam (+ i 3 clauses))
			 (declare-source-alias (new-array object 3
							  arg-name
							  assignment-arrow
							  value-expression)
					       value-expression)))))
	      (set (vector-ref app 0) lam)
	      (set (vector-ref lam (+ clauses 2)) lambda-sign)
	      (dotimes (j body-length)
		(let ((e (vector-ref arr
				     (+ (* clauses 3)
					(if named? 3 1)
					j))))
		  (when (eq? e s-equal)
		    (throw (parse-error "Found = in body of with - typeo in variables section?"
					arr)))
		  (set (vector-ref lam (+ j
					  (* clauses 2)
					  3))
		       e)))
	      (parse p app p)))))))

  (define-parser (->)
    "Creates a procedure.\\nArguments (names for inputs) appear on the left of the arrow.\\nThe result expression(s) appear on the right."
    lambda-parser s-body arr p
    (check-length arr 0 0)
    (let ((arrow (index-of arr lambda-arrow))
	  (named? (and (> (count arr) 1)
		       (eq? (vector-ref arr 1) s-colon))))
      (let ((varstart (if named? 2 0))
	    (mysnl (let ((loc (as p local-environment-parser)))
		     (if (null? loc)
			 0
			 (+ (nesting-level loc) 1)))))
      (let ((body-start (+ arrow 1)))
      (let ((proc-name (if (and named?
				;; KLUGE!
				;; Need this to keep from accidentally
				;; rebinding the with macro!
				(not (eq? (vector-ref arr 0)
					  s-with)))
			   (cast symbol (vector-ref arr 0))
			   null))
	    (docstring (if (and (< body-start (count arr))
				(is? (vector-ref arr body-start)
				     string)
				(< arrow (- (count arr) 2)))
			   (cast string (vector-ref arr body-start))
			   null))
	    (arg-count (if named?
			   (- arrow 2)
			   arrow)))
	(unless (null? docstring)
	  (set body-start (+ body-start 1)))
	(let ((proc-var (if named?
			    (local-variable proc-name (type->clr-type object)
					    null -1 mysnl)
			    null))
	      (required-arguments 0)
	      (optional-arguments 0)
	      (rest-arg -1)
	      (rest-arg-type null)
	      (keywords-start -1)
	      (e-index 0)
	      (arg-names (new-array object arg-count))
	      (visible-arg-names (new-array object arg-count))
	      (args (array-list))
	      (body-length (- (count arr)
			      body-start)))
	  (when (< body-length 1)
	    (throw (missing-body-error "Procedure has no result expression"
						 arr)))
	  (dotimes (i (- arrow varstart))
	    (let ((var (vector-ref arr (+ i varstart))))
	      (cond ((null? var)
		     (throw (invalid-argument-declaration-error
			     var)))
		    ((is? var local-variable)
		     (let ((lv (cast local-variable var)))
		       (set (vector-ref arg-names i) 
			    (vname lv))
		       ;; Leave slot in visible-arg-names blank so it
		       ;; won't capture the name.
		       (add args lv)
		       (set (snl lv) mysnl)
		       (set (index lv) e-index)
		       (cond ((or (optional? lv)
				  (> optional-arguments 0))
			      (set optional-arguments (+ optional-arguments 1))
			      (when (null? (default-value lv))
				(set (default-value lv)
				     (constant null))))
			     (else
			      (set required-arguments (+ required-arguments 1))))
		       (set e-index (+ e-index 1))))
		    ((eq? var s-ellipsis)
		     (when (= i 0)
		       (throw (procedure-syntax-error "Must have an argument name before an ellipsis"
						      arr)))
		     (when (>= keywords-start 0)
		       (throw (procedure-syntax-error "Can't have a rest argument in the keywords list"
						      arr)))
		     (if (> optional-arguments 0)
			 (set optional-arguments (- optional-arguments 1))
			 (set required-arguments (- required-arguments 1)))
		     (set (vector-ref arg-names i) var)
		     (set rest-arg (- i 1))
		     (set rest-arg-type
			  (declared-type (vector-ref args rest-arg)))
		     (set (declared-type (vector-ref args rest-arg))
			  (if (null? rest-arg-type)
			      null
			      (array-type-of rest-arg-type))))
		    ((eq? var keywords)
		     (set keywords-start e-index)
		     (set (vector-ref arg-names i) var))
		    (else
		     (let ((v (parse-argument-declaration var e-index mysnl)))
		       (cond ((>= keywords-start 0)
			      (when (null? (default-value v))
				(set (default-value v) (constant null))))
			     ((or (optional? v)
				  (> optional-arguments 0))
			      (set optional-arguments (+ optional-arguments 1))
			      (when (null? (default-value v))
				(throw (procedure-syntax-error "Non-optional argument appears after optional argument"
							       v))))
			     (else
			      (set required-arguments (+ required-arguments 1))))
		       (set (vector-ref arg-names i) 
			    (vname v))
		       (set (vector-ref visible-arg-names e-index) 
			    (vname v))
		       (add args v)
		       (set e-index (+ e-index 1)))))))
	  (let ((args-array (new-array local-variable
				       (count args))))
	    (copy-to args args-array 0)
	    (let ((local (new local-environment-parser
			      proc-name proc-var
			      visible-arg-names args-array p mysnl)))
	      (dotimes (j (count args))
		(let ((d (default-value (vector-ref args-array j))))
		  (unless (null? d)
		    (set (default-value (vector-ref args-array j))
			 (parse local
				(cvalue (cast constant d))
				local)))))
	      (lambda-expression (if named?
				     (vector-ref arr 0)
				     null)
				 arg-names
				 args-array
				 required-arguments optional-arguments
				 rest-arg rest-arg-type keywords-start
				 (parse-body arr body-start
					     local #t)
				 docstring
				 mysnl))))))))))